home *** CD-ROM | disk | FTP | other *** search
/ HPAVC / HPAVC CD-ROM.iso / WINER.ZIP / TYPESORT.BAS < prev    next >
BASIC Source File  |  1992-05-13  |  4KB  |  139 lines
  1. '********** TYPESORT.BAS - performs a multi-key sort on any TYPE array
  2.  
  3. 'Copyright (c) 1992 Ethan Winer
  4.  
  5. DEFINT A-Z
  6.  
  7. DECLARE FUNCTION Compare3% (BYVAL Seg1, BYVAL Adr1, BYVAL Seg2, BYVAL Adr2, NumBytes)
  8. DECLARE SUB SwapMem (BYVAL Seg1, BYVAL Adr1, BYVAL Seg2, BYVAL Adr2, BYVAL Length)
  9. DECLARE SUB TypeSort (Segment, Address, ElSize, Offset, KeySize, NumEls)
  10.  
  11. CONST NumEls% = 23              'this fits on the screen
  12.  
  13. TYPE MyType
  14.   LastName  AS STRING * 10
  15.   FirstName AS STRING * 10
  16.   Dollars   AS STRING * 6
  17.   Cents     AS STRING * 2
  18. END TYPE
  19. REDIM Array(1 TO NumEls%) AS MyType
  20.  
  21. '---- Disable all but one of the following blocks to test
  22.  
  23. Offset = 27                 'start sorting with Cents
  24. ElSize = LEN(Array(1))      'the length of each element
  25. KeySize = 2                 'sort on the Cents only
  26.  
  27. Offset = 21                 'start sorting with Dollars
  28. ElSize = LEN(Array(1))      'the length of each element
  29. KeySize = 8                 'sort Dollars and Cents only
  30.  
  31. Offset = 11                 'start sorting with FirstName
  32. ElSize = LEN(Array(1))      'the length of each element
  33. KeySize = 18                'sort FirstName through Cents
  34.  
  35. Offset = 1                  'start sorting with LastName
  36. ElSize = LEN(Array(1))      'the length of each element
  37. KeySize = ElSize            'sort based on all 4 fields
  38.  
  39. FOR X = 1 TO NumEls%        'build the array from DATA
  40.   READ Array(X).LastName
  41.   READ Array(X).FirstName
  42.   READ Amount$              'format the amount into money
  43.   Dot = INSTR(Amount$, ".")
  44.   IF Dot THEN
  45.     RSET Array(X).Dollars = LEFT$(Amount$, Dot - 1)
  46.     Array(X).Cents = LEFT$(MID$(Amount$, Dot + 1) + "00", 2)
  47.   ELSE
  48.     RSET Array(X).Dollars = Amount$
  49.     Array(X).Cents = "00"
  50.   END IF
  51. NEXT
  52.  
  53. Segment = VARSEG(Array(1))      'show where the array is
  54. Address = VARPTR(Array(1))      '  located in memory
  55. CALL TypeSort(Segment, Address, ElSize, Offset, KeySize, NumEls%)
  56.  
  57. CLS                             'display the results
  58. FOR X = 1 TO NumEls%
  59.   PRINT Array(X).LastName, Array(X).FirstName,
  60.   PRINT Array(X).Dollars; "."; Array(X).Cents
  61. NEXT
  62.  
  63. DATA Smith, John, 123.45
  64. DATA Cramer, Phil, 11.51
  65. DATA Hogan, Edward, 296.08
  66. DATA Cramer, Phil, 112.01
  67. DATA Malin, Donald, 13.45
  68. DATA Cramer, Phil, 111.3
  69. DATA Smith, Ralph, 123.22
  70. DATA Smith, John, 112.01
  71. DATA Hogan, Edward, 8999.04
  72. DATA Hogan, Edward, 8999.05
  73. DATA Smith, Bob, 123.45
  74. DATA Cramer, Phil, 11.50
  75. DATA Hogan, Edward, 296.88
  76. DATA Malin, Donald, 13.01
  77. DATA Cramer, Phil, 111.1
  78. DATA Smith, Ralph, 123.07
  79. DATA Smith, John, 112.01
  80. DATA Hogan, Edward, 8999.33
  81. DATA Hogan, Edward, 8999.17
  82. DATA Hogan, Edward, 8999.24
  83. DATA Smith, John, 123.05
  84. DATA Cramer, David, 1908.80
  85. DATA Cramer, Phil, 112
  86.  
  87. SUB TypeSort (Segment, Address, ElSize, Displace, KeySize, NumEls) STATIC
  88.  
  89. REDIM QStack(NumEls \ 5 + 10)   'create a stack sufficient for 2500 elements
  90.  
  91. First = 1                       'initialize working variables
  92. Last = NumEls
  93. Offset = Displace - 1           'make zero-based now for speed later
  94.  
  95. DO
  96.   DO
  97.     Temp = (Last + First) \ 2   'seek midpoint
  98.     I = First
  99.     J = Last
  100.  
  101.     DO          'change -1 to 1 and 1 to -1 below to sort descending
  102.       WHILE Compare3%(Segment, Address + Offset + (I - 1) * ElSize, Segment, Address + Offset + (Temp - 1) * ElSize, KeySize) = -1
  103.         I = I + 1
  104.       WEND
  105.       WHILE Compare3%(Segment, Address + Offset + (J - 1) * ElSize, Segment, Address + Offset + (Temp - 1) * ElSize, KeySize) = 1
  106.         J = J - 1
  107.       WEND
  108.       IF I > J THEN EXIT DO
  109.       IF I < J THEN
  110.         CALL SwapMem(Segment, Address + (I - 1) * ElSize, Segment, Address + (J - 1) * ElSize, ElSize)
  111.         IF Temp = I THEN
  112.           Temp = J
  113.         ELSEIF Temp = J THEN
  114.           Temp = I
  115.         END IF
  116.       END IF
  117.       I = I + 1
  118.       J = J - 1
  119.     LOOP WHILE I <= J
  120.  
  121.     IF I < Last THEN
  122.       QStack(StackPtr) = I             'Push I
  123.       QStack(StackPtr + 1) = Last      'Push Last
  124.       StackPtr = StackPtr + 2
  125.     END IF
  126.  
  127.     Last = J
  128.   LOOP WHILE First < Last
  129.  
  130.   IF StackPtr = 0 THEN EXIT DO          'Done
  131.   StackPtr = StackPtr - 2
  132.   First = QStack(StackPtr)              'Pop First
  133.   Last = QStack(StackPtr + 1)           'Pop Last
  134. LOOP
  135.  
  136. ERASE QStack                    'delete the stack array
  137.  
  138. END SUB
  139.